Excel VBA Examples(2)

Microsoft Excel VBA Examples

' You should create a reference to the Outlook Object Library in the VBEditor

Sub Send_Msg()
Dim objOL As New Outlook.Application
Dim objMail As MailItem

Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)

With objMail
    .To = "name@domain.com"
    .Subject = "Automated Mail Response"
    .Body = "This is an automated message from Excel. " & _
        "The cost of the item that you inquired about is: " & _
        Format(Range("A1").Value, "$ #,###.#0") & "."
    .Display
End With

Set objMail = Nothing
Set objOL = Nothing
End Sub

Back

Sub Shape_Index_Name()
Dim myVar As Shapes
Dim shp As Shape
Set myVar = Sheets(1).Shapes

For Each shp In myVar
    MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _
        & shp.Name
Next

End Sub

Back

' You should create a reference to the Word Object Library in the VBEditor

Sub Open_MSWord()
On Error GoTo errorHandler
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim mywdRange As Word.Range
Set wdApp = New Word.Application

With wdApp
    .Visible = True
    .WindowState = wdWindowStateMaximize
End With

Set myDoc = wdApp.Documents.Add

Set mywdRange = myDoc.Words(1)

With mywdRange
    .Text = Range("F6") & " This text is being used to test subroutine." & _
        "  More meaningful text to follow."
    .Font.Name = "Comic Sans MS"
    .Font.Size = 12
    .Font.ColorIndex = wdGreen
    .Bold = True
End With

errorHandler:

Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
End Sub

Back

Sub ShowStars()
Randomize
StarWidth = 25
StarHeight = 25

    For i = 1 To 10
        TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
        LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
        Set NewStar = ActiveSheet.Shapes.AddShape _
          (msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
        NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
        Application.Wait Now + TimeValue("00:00:01")
        DoEvents
    Next i

    Application.Wait Now + TimeValue("00:00:02")

Set myShapes = Worksheets(1).Shapes
    For Each shp In myShapes
        If Left(shp.Name, 9) = "AutoShape" Then
            shp.Delete
            Application.Wait Now + TimeValue("00:00:01")
        End If
    Next
    Worksheets(1).Shapes("Message").Visible = True
End Sub

Back

' This sub looks at every cell on the worksheet and
' if the cell DOES NOT have a formula, a date or text
' and the cell IS numeric, it unlocks the cell and
' makes the font blue. For everything else, it locks
' the cell and makes the font black. It then protects
' the worksheet.
' This has the effect of allowing someone to edit the
' numbers but they cannot change the text, dates or
' formulas.

Sub Set_Protection()
On Error GoTo errorHandler
Dim myDoc As Worksheet
Dim cel As Range
Set myDoc = ActiveSheet
myDoc.UnProtect
For Each cel In myDoc.UsedRange
    If Not cel.HasFormula And _
    Not TypeName(cel.Value) = "Date" And _
    Application.IsNumber(cel) Then
        cel.Locked = False
        cel.Font.ColorIndex = 5
    Else
        cel.Locked = True
        cel.Font.ColorIndex = xlColorIndexAutomatic
    End If
Next
myDoc.Protect
Exit Sub
errorHandler:
MsgBox Error
End Sub

Back

' Tests the value in each cell of a column and if it is greater
' than a given number, places it in another column.  This is just
' an example so the source range, target range and test value may
' be adjusted to fit different requirements.

Sub Test_Values()
Dim topCel As Range, bottomCel As Range, _
    sourceRange As Range, targetRange As Range
Dim x As Integer, i As Integer, numofRows As Integer
Set topCel = Range("A2")
Set bottomCel = Range("A65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End     ' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("D2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
    If Application.IsNumber(sourceRange(i)) Then
        If sourceRange(i) > 1300000 Then
            targetRange(x) = sourceRange(i)
            x = x + 1
        End If
    End If
Next
End Sub

Back

Sub CountNonBlankCells()               'Returns a count of  non-blank cells in a selection
Dim myCount As Integer                   'using the CountA ws function (all non-blanks)
myCount = Application.CountA(Selection)
MsgBox "The number of non-blank cell(s) in this selection is :  "_
     & myCount, vbInformation, "Count Cells"
End Sub


Sub CountNonBlankCells2()              'Returns a count of non-blank cells in a selection
Dim myCount As Integer                    'using the Count ws function (only counts numbers, no text)
myCount = Application.Count(Selection)
MsgBox "The number of non-blank cell(s) containing numbers is : "_
    & myCount, vbInformation, "Count Cells"
End Sub


Sub CountAllCells                                  'Returns a count of all cells in a selection
Dim myCount As Integer                       'using the Selection and Count properties
myCount = Selection.Count
MsgBox "The total number of cell(s) in this selection is : "_
     & myCount, vbInformation, "Count Cells"
End Sub


Sub CountRows()                                    'Returns a count of the number of rows in a selection
Dim myCount As Integer                       'using the Selection & Count properties & the Rows method
myCount = Selection.Rows.Count
MsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"
End Sub


Sub CountColumns()                             'Returns a count of the number of columns in a selection
Dim myCount As Integer                      'using the Selection & Count properties & the Columns method
myCount = Selection.Columns.Count
MsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"
End Sub


Sub CountColumnsMultipleSelections()         'Counts columns in a multiple selection
AreaCount = Selection.Areas.Count
If AreaCount <= 1 Then
    MsgBox "The selection contains " & _
        Selection.Columns.Count & " columns."
Else
    For i = 1 To AreaCount
        MsgBox "Area " & i & " of the selection contains " & _
            Selection.Areas(i).Columns.Count & " columns."
    Next i
End If
End Sub


Sub addAmtAbs()
Set myRange = Range("Range1")   '   Substitute your range here
mycount = Application.Count(myRange)
ActiveCell.Formula = "=SUM(B1:B" & mycount & ")"  '   Substitute your cell address here
End Sub


Sub addAmtRel()
Set myRange = Range("Range1")   '   Substitute your range here
mycount = Application.Count(myRange)
ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)"  '   Substitute your cell address here
End Sub

Back

Sub SelectDown()
    Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub


Sub Select_from_ActiveCell_to_Last_Cell_in_Column()
Dim topCel As Range
Dim bottomCel As Range
On Error GoTo errorHandler
Set topCel = ActiveCell
Set bottomCel = Cells((65536), topCel.Column).End(xlUp)
    If bottomCel.Row >= topCel.Row Then
        Range(topCel, bottomCel).Select
    End If
Exit Sub
errorHandler:
MsgBox "Error no. " & Err & " - " & Error
End Sub


Sub SelectUp()
    Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub


Sub SelectToRight()
    Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub


Sub SelectToLeft()
    Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub


Sub SelectCurrentRegion()
    ActiveCell.CurrentRegion.Select
End Sub


Sub SelectActiveArea()
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub


Sub SelectActiveColumn()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
    If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
    Range(TopCell, BottomCell).Select
End Sub


Sub SelectActiveRow()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
    If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
    Range(LeftCell, RightCell).Select
End Sub


Sub SelectEntireColumn()
    Selection.EntireColumn.Select
End Sub


Sub SelectEntireRow()
    Selection.EntireRow.Select
End Sub


Sub SelectEntireSheet()
    Cells.Select
End Sub


Sub ActivateNextBlankDown()
    ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub


Sub ActivateNextBlankToRight()
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(0, 1).Select
    Loop
End Sub


Sub SelectFirstToLastInRow()
    Set LeftCell = Cells(ActiveCell.Row, 1)
    Set RightCell = Cells(ActiveCell.Row, 256)

    If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
    If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
    If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
End Sub


Sub SelectFirstToLastInColumn()
    Set TopCell = Cells(1, ActiveCell.Column)
    Set BottomCell = Cells(16384, ActiveCell.Column)

    If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
    If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
    If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select
End Sub


Sub SelCurRegCopy()
    Selection.CurrentRegion.Select
    Selection.Copy
    Range("A17").Select ' Substitute your range here
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

Back

Microsoft Excel VBA Examples